Usenet 1993 July/InfoMagic USENET CD-ROM July 1993.ISO/sources/unix/volume10/comobj.lisp/part02

Text File | 1987-07-30 | 57.3 KB | 1,921 lines

Path: uunet!rs
From: [e-mail] (Rich Salz)
Newsgroups: comp.sources.unix
Subject: v10i076:  Common Objects, Common Loops, Common Lisp, Part02/13
Message-ID: <[e-mail]>
Date: 31 Jul 87 19:58:13 GMT
Organization: UUNET Communications Services, Arlington, VA
Lines: 1910
Approved: [e-mail]

Submitted-by: Roy D'Souza <[e-mail]>
Posting-number: Volume 10, Issue 76
Archive-name: comobj.lisp/Part02

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 2 (of 13)."
# Contents:  3600-low.l co-macros.l co-prof.l co-sfun.l co-test.l
#   dfun-templ.l pcl-patches.l xerox-low.l
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f '3600-low.l' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'3600-low.l'\"
else
echo shar: Extracting \"'3600-low.l'\" \(8740 characters\)
sed "s/^X//" >'3600-low.l' <<'END_OF_FILE'
X;;; -*- Mode:LISP; Package:(PCL Lisp 1000); Base:10.; Syntax:Common-lisp; Patch-File: Yes -*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted.  Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;;   CommonLoops Coordinator
X;;;   Xerox Artifical Intelligence Systems
X;;;   2400 Hanover St.
X;;;   Palo Alto, CA 94303
X;;; (or send Arpanet mail to [e-mail])
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X;;;
X;;; This is the 3600 version of the file portable-low.
X;;;
X
X(in-package 'pcl)
X
X(defmacro without-interrupts (&body body)
X  `(zl:without-interrupts ,.body))
X
X  ;;
X;;;;;; Load Time Constants
X  ;;
X;;;
X;;; This implementation of load-time-eval exploits the perhaps questionable
X;;; feature that it is possible to define optimizers on macros.
X;;;
X;;;   WHEN                       EXPANDS-TO
X;;;   compile to a file          (#:EVAL-AT-LOAD-TIME-MARKER . <form>)
X;;;   compile to core            '<result of evaluating form>
X;;;   not in compiler at all     (progn <form>)
X;;;
X(defmacro load-time-eval (form)
X  ;; The interpreted definition of load-time-eval.  This definition
X  ;; never gets compiled.
X  (let ((value (gensym)))
X    `(multiple-value-bind (,value)
X     (progn ,form)
X       ,value)))
X
X(compiler:deftransformer (load-time-eval compile-load-time-eval)
X             (form &optional interpreted-form)
X  (ignore interpreted-form)
X  ;; When compiling a call to load-time-eval the compiler will call
X  ;; this optimizer before the macro expansion.
X  (if zl:compiler:(and (boundp '*compile-function*) ;Probably don't need
X                            ;this boundp check
X                            ;but it can't hurt.
X               (funcall *compile-function* :to-core-p))
X      ;; Compiling to core.
X      ;; Evaluate the form now, and expand into a constant
X      ;; (the result of evaluating the form).
X      `',(eval (cadr form))
X      ;; Compiling to a file.
X      ;; Generate the magic which causes the dumper compiler and loader
X      ;; to do magic and evaluate the form at load time.
X      `',(cons compiler:eval-at-load-time-marker (cadr form))))
X
X  ;;
X;;;;;; Memory Block primitives.
X  ;;
X
X
X(defmacro make-memory-block (size &optional area)
X  `(make-array ,size :area ,area))
X
X(defmacro memory-block-ref (block offset)    ;Don't want to go faster yet.
X  `(aref ,block ,offset))
X
X(defvar class-wrapper-area)
X(eval-when (load eval)
X  (si:make-area :name 'class-wrapper-area
X        :room t
X        :gc :static))
X
X
X;;;
X;;; Reimplementation OF %INSTANCE
X;;;
X;;; We take advantage of the fact that Symbolics defstruct doesn't depend on
X;;; the fact that Common Lisp defstructs are fixed length.  This allows us to
X;;; use defstruct to define a new type, but use internal structure allocation
X;;; code to make structure of that type of any length we like.
X;;;
X;;; In Symbolics Common Lisp, structures are really just arrays with a magic
X;;; bit set.  The first element of the array points to the symbol which is
X;;; the name of this structure.  The remaining elements are used for the
X;;; slots of the structure.
X;;;
X;;; In our %instance datatype, the array look like
X;;;
X;;;  element 0:  The symbol %INSTANCE, this tells the system what kind of
X;;;              structure this is.
X;;;  element 1:  The meta-class of this %INSTANCE
X;;;  element 2:  This is used to store the value of %instance-ref slot 0.
X;;;  element 3:  This is used to store the value of %instance-ref slot 1.
X;;;     .                                .
X;;;     .                                .
X;;;
X(defstruct (%instance (:print-function print-instance)
X              (:constructor nil)
X              (:predicate %instancep))
X  meta-class)
X
X(zl:defselect ((:property %instance zl:named-structure-invoke))
X  (:print-self (iwmc-class stream print-depth *print-escape*)
X           (print-instance iwmc-class stream print-depth))
X  (:describe   (iwmc-class &optional no-complaints)
X           (ignore no-complaints)
X           (describe-instance iwmc-class)))
X
X(defmacro %make-instance (meta-class size)
X  (let ((instance-var (gensym)))
X    `(let ((,instance-var (make-array (+ 2 ,size))))
X       (setf (SI:ARRAY-NAMED-STRUCTURE-BIT ,instance-var) 1
X         (aref ,instance-var 0) '%instance
X         (aref ,instance-var 1) ,meta-class)
X       ,instance-var)))
X
X(defmacro %instance-ref (instance index)
X  `(aref ,instance (+ ,index 2)))
X
X  ;;
X;;;;;; Cache No's
X  ;;
X
X(zl:defsubst symbol-cache-no (symbol mask)
X  (logand (si:%pointer symbol) mask))
X
X(compiler:defoptimizer (symbol-cache-no fold-symbol-cache-no) (form)
X  (if (and (constantp (cadr form))
X       (constantp (caddr form)))
X      `(load-time-eval (logand (si:%pointer ,(cadr form)) ,(caddr form)))
X      form))
X
X(defmacro object-cache-no (object mask)
X  `(logand (si:%pointer ,object) ,mask))
X
X  ;;
X;;;;;; printing-random-thing-internal
X  ;;
X(defun printing-random-thing-internal (thing stream)
X  (format stream "~O" (si:%pointer thing)))
X
X  ;;
X;;;;;; function-arglist
X  ;;
X;;;
X;;; This is hard, I am sweating.
X;;;
X(defun function-arglist (function) (zl:arglist function t))
X
X(defun function-pretty-arglist (function) (zl:arglist function))
X
X;; Unfortunately, this doesn't really work...
X(defun set-function-pretty-arglist (function new-value)
X  (ignore function new-value))
X
X;; But this does...
X(zl:advise zl:arglist
X       :after
X       pcl-patch-to-arglist
X       ()
X  (let ((function (car zl:arglist))
X    (discriminator nil))
X      (when (and (symbolp function)
X         (setq discriminator (discriminator-named function)))
X    (setq values (list (discriminator-pretty-arglist discriminator))))))
X
X
X  ;;
X;;;;;;
X  ;;
X
X(defun record-definition (name type &rest args)
X  (case type
X    (method (si:record-source-file-name name 'zl:defun t))
X    (class ())))
X
X(defun compile-time-define (type name &rest ignore)
X  (case type
X    (defun (compiler:file-declare name 'zl:def 'zl:ignore))))
X
X  ;;
X;;;;;; Environment support and Bug-Fixes
X  ;;
X;;; Some VERY basic environment support for the 3600, and some bug fixes and
X;;; improvements to 3600 system utilities.  These may need some work before
X;;; they will work in release 7.
X;;;
X(eval-when (load eval)
X  (setf
X    (get 'defmeth 'zwei:definition-function-spec-type) 'defun
X   ;(get 'defmeth 'zwei:definition-function-spec-finder-template) '(0 1)
X    (get 'ndefstruct 'zwei:definition-type-name) "Class"
X    (get 'ndefstruct 'zwei:definition-function-spec-finder-template) '(0 1))
X  )
X
X;;; These changes let me dump instances of PCL metaclasses in files, and also arrange
X;;; for the #S syntax to work for PCL instances.
X;;; si:dump-object and si:get-defstruct-constructor-macro-name get "advised".
X;;; Actually the advice is done by hand since it doesn't get compiled otherwise.
X
X(defvar *old-dump-object*)
X(defun patched-dump-object (object stream)
X  (if (or (si:send si:*bin-dump-table* :get-hash object)
X      (not (and (%instancep object)
X            (class-standard-constructor (class-of object)))))
X      (funcall *old-dump-object* object stream)
X      ;; Code pratically copied from dump-instance.
X      (let ((index (si:enter-table object stream t t)))
X    (si:dump-form-to-eval
X      (cons (class-standard-constructor (class-of object))
X        (iterate
X          ((slot in (all-slots object) by cddr)
X           (val in (cdr (all-slots object)) by cddr))
X          (collect (make-keyword slot))
X          (collect `',val)))
X      stream)
X    (si:finish-enter-table object index))))
X
X(unless (boundp '*old-dump-object*)
X  (setf *old-dump-object* (symbol-function 'si:dump-object)
X    (symbol-function 'si:dump-object) 'patched-dump-object))
X
X(defvar *old-get-defstruct-constructor-macro-name*)
X(defun patched-get-defstruct-constructor-macro-name (structure)
X  (let ((class (class-named structure t)))
X    (if class
X    (class-standard-constructor class)
X    (funcall *old-get-defstruct-constructor-macro-name* structure))))
X
X
X(unless (boundp '*old-get-defstruct-constructor-macro-name*)
X  (setf *old-get-defstruct-constructor-macro-name*
X       (symbol-function 'si:get-defstruct-constructor-macro-name)
X    (symbol-function 'si:get-defstruct-constructor-macro-name)
X       'patched-get-defstruct-constructor-macro-name))
X
END_OF_FILE
if test 8740 -ne `wc -c <'3600-low.l'`; then
    echo shar: \"'3600-low.l'\" unpacked with wrong size!
fi
# end of '3600-low.l'
fi
if test -f 'co-macros.l' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'co-macros.l'\"
else
echo shar: Extracting \"'co-macros.l'\" \(7103 characters\)
sed "s/^X//" >'co-macros.l' <<'END_OF_FILE'
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; File:         co-macros.l
X; RCS:          $Revision: 1.1 $
X; SCCS:         %A% %G% %U%
X; Description:  Macros used by Interface For CommonObjects
X;               with co parser in CL.
X; Author:       James Kempf, HP/DCC
X; Created:      31-Jul-86
X; Modified:     11-Mar-87 22:22:44 (James Kempf)
X; Language:     Lisp
X; Package:      COMMON-OBJECTS
X; Status:       Distribution
X;
X; (c) Copyright 1987, HP Labs, all rights reserved.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; Copyright (c) 1987 Hewlett-Packard Corporation. All rights reserved.
X;
X; Use and copying of this software and preparation of derivative works based
X; upon this software are permitted.  Any distribution of this software or
X; derivative works must comply with all applicable United States export
X; control laws.
X;
X; This software is made available AS IS, and Hewlett-Packard Corporation makes
X; no warranty about the software, its performance or its conformity to any
X; specification.
X;
X; Suggestions, comments and requests for improvement may be mailed to
X; [e-mail]
X
X;;;-*-Mode:LISP; Package:(CO (PCL LISP)); Base:10; Syntax: Common-lisp-*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted.  Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;;   CommonLoops Coordinator
X;;;   Xerox Artifical Intelligence Systems
X;;;   2400 Hanover St.
X;;;   Palo Alto, CA 94303
X;;; (or send Arpanet mail to [e-mail])
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;  Preliminaries
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;;The CommonObjects interface is in the COMMON-OBJECTS package. We need
X;;;  both PCL and the CommonObjects parser, which is in the
X;;   COMMON-OBJECTS-PARSER package. Note that PCL is assumed to be
X;;   loaded.
X
X(provide "co-macros")
X
X(in-package 'common-objects :nicknames '(co) :use '(lisp pcl walker))
X
X;;Export these symbols. They are the only ones which clients should see.
X
X(export
X  '(
X    make-instance
X    define-type
X    define-method
X    call-method
X    apply-method
X    assignedp
X    undefine-type
X    rename-type
X    undef Artifical Intelligence Systems
X;;;   2400 Hanovration-p
X    send?
X    instance
X    import-specialized-functions
X  )
X)
X
X;;Need PCL and patches
X
X(require "pcl")
X(require "pcl-patches")
X
X;;Need the parser
X
X(require "co-parse")
X
X;;Use the parser's package
X
X(use-package 'co-parser)
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;  Constant Definition
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;;Need this flag to indicate that an instance variable is uninitialized.
X
X(defconstant $UNINITIALIZED-VARIABLE-FLAG 'LISP::*UNDEFINED*)
X
X;;Offsets of important things in instances.
X;;Location of class object.
X
X(defconstant $CLASS-OBJECT-INDEX 0)
X
X;;Location of pointer to self.
X
X(defconstant $SELF-INDEX 1)
X
X;;Starting index of parents.
X
X(defconstant $START-OF-PARENTS 2)
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;  Special Variable Definition
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;*special-functions-list*-Holds a list of uninterned symbols for TYPE-OF,
X;;  TYPEP, EQL, EQUAL, and EQUALP. These symbols have their function cells
X;;  bound to special functions which use CommonObjects messaging if the
X;;  argument is a CommonObjects object.
X
X(defvar *special-functions-list*
X  (list
X    (cons ':type-of (make-symbol "TYPE-OF"))
X    (cons ':typep (make-symbol "TYPEP"))
X    (cons ':eql (make-symbol "EQL"))
X    (cons ':equal (make-symbol "EQUAL"))
X    (cons ':equalp (make-symbol "EQUALP"))
X  )
X)
X
X;;*universal-methods*-List of universal methods
X
X(defvar *universal-methods*
X  '(
X    :init
X    :initialize
X    :print
X    :describe
X    :eql
X    :equal
X    :equalp
X    :typep
X    :copy
X    :copy-instance
X    :copy-state
X  )
X)
X
X;;*universal-method-selectors*-List of selectors for universal
X;;  methods
X
X(defvar *universal-method-selectors* NIL)
X
X;;*keyword-standin-package*-Package for interning methods as functions.
X;;  CommonObjects "encourages" the use of keywords as method names,
X;;  but not all CL's allow keyword symbol function cells to be
X;;  occupied.
X
X(eval-when (compile load eval)
X  (defvar *keyword-standin-package*
X    (or (find-package 'keyword-standin) (make-package 'keyword-standin))
X  )
X)
X
X;;;Unuse the lisp package in the keyword-standin package, to
X;;;  avoid conflicts with named functions.
X
X(unuse-package 'lisp *keyword-standin-package*)
X
X;;*special-method-symbols*-List of special method symbols which
X;;  shouldn't go into the keyword-standin package, paired with
X;;  their method names.
X
X(defvar *special-method-symbols*
X  (list
X      (cons ':print 'print-instance)
X  )
X)
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X;    Support for Using Keywords as Method Names
X;
X;  These macros and functions translate keyword method names into
X;  names in a package. Some Common Lisps do allow keyword symbols
X;  to have an associated function, others don't. Rather than
X;  differentiating, a single package, KEYWORD-STANDIN, is used
X;  for method symbols which are keywords.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;special-keyword-p-Return T if the keyword is a special method
X;;  symbol.
X
X(defmacro special-keyword-p (keyword)
X  `(assoc ,keyword *special-method-symbols* :test #'eq)
X
X) ;end special-keyword-p
X
X;;keyword-standin-special-Return the special symbol for this
X;;  keyword.
X
X(defmacro keyword-standin-special (keyword)
X  `(cdr (assoc ,keyword *special-method-symbols* :test #'eq))
X
X) ;end keyword-standin-special
X
X;;special-method-p-Return T if the symbol is a special method
X;;  symbol.
X
X(defmacro special-method-p (symbol)
X  `(rassoc ,symbol *special-method-symbols* :test #'eq)
X
X) ;end special-method-p
X
X;;unkeyword-standin-special-Return the keyword for this
X;;  special method
X
X(defmacro unkeyword-standin-special (symbol)
X  `(car (rassoc ,symbol *special-method-symbols* :test #'eq))
X
X) ;end unkeyword-standin-special
X
X;;keyword-standin-Get a standin symbol for a keyword
X
X;;; end of co-macros.l ;;;;;
X
END_OF_FILE
if test 7103 -ne `wc -c <'co-macros.l'`; then
    echo shar: \"'co-macros.l'\" unpacked with wrong size!
fi
# end of 'co-macros.l'
fi
if test -f 'co-prof.l' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'co-prof.l'\"
else
echo shar: Extracting \"'co-prof.l'\" \(5412 characters\)
sed "s/^X//" >'co-prof.l' <<'END_OF_FILE'
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; File:         co-prof.l
X; SCCS:         %A% %G% %U%
X; Description:  Profiling For COOL
X; Author:       James Kempf, HP/DCC
X; Created:      10-Feb-87
X; Modified:     25-Feb-87 10:51:31 (James Kempf)
X; Language:     Lisp
X; Package:      TEST
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(in-package 'test)
X
X(require "co")
X
X(use-package 'co)
X
X(require "co-profmacs")
X
X;;Collection Variable for Test Functions
X
X(defvar *function-symbols* NIL)
X
X;;Default names for output file and output messages.
X;;  Can be overridden before this file is loaded.
X
X(defvar *output-file-name* "runprof.out")
X(defvar *definition-message* "COOL Definition Results")
X(defvar *redefinition-message* "COOL Redefinition Results")
X
X;;Run everything compiled so that best
X;;  times are obtained.
X
X;;Measurement of Type Definition
X
X;;Warmup
X
X(do-type-definition NIL 0 0)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;No instance variables and no parents
X
X(do-type-definition T 0 0)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;One instance variable and no parents
X
X(do-type-definition T 1 0)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;Two instance variables and no parents
X
X(do-type-definition T 2 0)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;Three instance variables and no parents
X
X(do-type-definition T 3 0)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;No variables and one parent
X
X(do-type-definition T 0 1)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;No variables and two parents
X
X(do-type-definition T 0 2)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;No variables and three parents
X
X(do-type-definition T 0 3)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;Measure Instance Creation
X
X;;Warmup
X
X(do-instance-creation NIL 0 0)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;No instance variables and no parents
X
X(do-instance-creation T 0 0)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;One instance variable and no parents
X
X(do-instance-creation T 1 0)
X(funcall (first *function-symbols*))
X
X;;Two instance variables and no parents
X
X(do-instance-creation T 2 0)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;Three instance variables and no parents
X
X(do-instance-creation T 3 0)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;No variables and one parent
X
X(do-instance-creation T 0 1)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;No variables and two parents
X
X(do-instance-creation T 0 2)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;No variables and three parents
X
X(do-instance-creation T 0 3)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;Measurement of Method Definition
X
X(do-method-definition NIL 0 temp1)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;So that new symbols will be generated
X
X(setf *list-of-method-symbols* NIL)
X
X;;No predefined method
X
X(do-method-definition T 0 temp1)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;Measure method invocation
X
X(do-messaging T 1 temp1)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;One predefined method
X
X(do-method-definition T 1 temp2)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;Measure method invocation
X
X(do-messaging T 2 temp1 temp2)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;Two predefined methods
X
X(do-method-definition T 2 temp3)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;Measure method invocation
X
X(do-messaging T 3 temp1 temp2 temp3)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;Three predefined methods
X
X(do-method-definition T 3 temp4)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;Measure method invocation
X
X(do-messaging T 4 temp1 temp2 temp3 temp4)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;Method Invocation and Inheritence
X
X(do-inherited-messaging NIL 0 g0f)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X;;No inheritence
X
X(do-inherited-messaging T 0 g0f)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X
X;;One level
X
X(do-inherited-messaging T 1 g1f)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X
X;;Two levels
X
X(do-inherited-messaging T 2 g2f)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X
X;;Three levels
X
X(do-inherited-messaging T 3 g3f)
X(compile (first *function-symbols*))
X(funcall (first *function-symbols*))
X
X
X;;Dump out the results
X
X(print-results *output-file-name* *definition-message*)
X
X;;Run Everything Again
X
X(dolist (l (reverse *function-symbols*))
X  (funcall l)
X)
X
X;;And dump results
X
X(print-results *output-file-name* *redefinition-message*)
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(provide "co-prof")
X
END_OF_FILE
if test 5412 -ne `wc -c <'co-prof.l'`; then
    echo shar: \"'co-prof.l'\" unpacked with wrong size!
fi
# end of 'co-prof.l'
fi
if test -f 'co-sfun.l' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'co-sfun.l'\"
else
echo shar: Extracting \"'co-sfun.l'\" \(5643 characters\)
sed "s/^X//" >'co-sfun.l' <<'END_OF_FILE'
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; File:         co-sfun.l
X; RCS:          $Revision: 1.1 $
X; SCCS:         %A% %G% %U%
X; Description:  Override System Functions
X; Author:       James Kempf
X; Created:      March 10, 1987
X; Modified:     March 10, 1987  13:31:39 (Roy D'Souza)
X; Language:     Lisp
X; Package:      COMMON-OBJECTS
X; Status:       Distribution
X;
X; (c) Copyright 1987, HP Labs, all rights reserved.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; Copyright (c) 1987 Hewlett-Packard Corporation. All rights reserved.
X;
X; Use and copying of this software and preparation of derivative works based
X; upon this software are permitted.  Any distribution of this software or
X; derivative works must comply with all applicable United States export
X; control laws.
X;
X; This software is made available AS IS, and Hewlett-Packard Corporation makes
X; no warranty about the software, its performance or its conformity to any
X; specification.
X;
X; Suggestions, comments and requests for improvement may be mailed to
X; [e-mail]
X
X;;;-*-Mode:LISP; Package:(CO (PCL LISP)); Base:10; Syntax: Common-lisp-*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted.  Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;;   CommonLoops Coordinator
X;;;   Xerox Artifical Intelligence Systems
X;;;   2400 Hanover St.
X;;;   Palo Alto, CA 94303
X;;; (or send Arpanet mail to [e-mail])
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X
X(in-package 'common-objects :nicknames '(co) :use '(lisp pcl walker))
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X;    Overridden System Functions
X;
X;  The semantics of CommonObjects requires that the Lisp functions EQL, EQUAL,
X;  EQUALP, and TYPEP go through the corresponding universial methods rather
X;  than having their default behavior, and that TYPE-OF return the CommonObjects
X;  type. To avoid circularity problems, these functions are defined as
X;  special, non-interned symbols, and are SHADOWING-IMPORTED into the
X;  package by the user if this behavior is desired. Note, however,
X;  that the default Lisp symbols can't be specialized because otherwise
X;  circularity problems in PCL functions like CLASS-OF may occur. An application
X;  wanting to use them must call the function IMPORT-SPECIALIZED-FUNCTIONS
X;  (below) to get access.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(eval-when (load eval)
X
X  (progn
X
X   ;;For TYPE-OF
X
X    (setf
X      (symbol-function
X        (cdr (assoc ':type-of *special-functions-list* :test #'eq))
X      )
X      (function (lambda (object) (class-name (class-of object))))
X
X    ) ;setf
X
X   ;;For TYPEP
X
X    (setf
X      (symbol-function
X        (cdr (assoc ':typep *special-functions-list* :test #'eq))
X      )
X      (function
X        (lambda (object type)
X          (cond
X
X            ;;Object is a CommonObjects instance
X
X            (
X              (instancep object)
X          (keyword-standin::typep object type)
X            )
X
X            ;;Type is a CommonObjects type
X
X            (
X              (member type (defined-classes))
X              NIL
X            )
X
X            ;;Default
X
X            (
X              T
X              (lisp::typep object type)
X            )
X
X          ) ;cond
X        )
X      )
X    ) ;setf
X
X   ;;For EQL
X
X    (setf
X      (symbol-function
X        (cdr (assoc ':eql *special-functions-list* :test #'eq))
X      )
X      (function
X        (lambda (object1 object2)
X          (if (instancep object1)
X        (keyword-standin::eql object1 object2)
X            (lisp::eql object1 object2)
X          )
X        )
X      )
X    ) ;setf
X
X   ;;For EQUAL
X
X    (setf
X      (symbol-function
X        (cdr (assoc ':equal *special-functions-list* :test #'eq))
X      )
X      (function
X        (lambda (object1 object2)
X          (if (instancep object1)
X        (keyword-standin::equal object1 object2)
X            (lisp::equal object1 object2)
X          )
X        )
X      )
X    ) ;setf
X
X   ;;For EQUALP
X
X    (setf
X      (symbol-function
X        (cdr (assoc ':equalp *special-functions-list* :test #'eq))
X      )
X      (function
X        (lambda (object1 object2)
X          (if (instancep object1)
X        (keyword-standin::equalp object1 object2)
X            (lisp::equalp object1 object2)
X          )
X        )
X      )
X    ) ;setf
X
X  ) ;progn
X
X) ;eval-when
X
X;;import-specialized-functions-Import the specialized functions into
X;;  the current package. This will override the Lisp package
X;;  symbols.
X
X(defmacro import-specialized-functions ()
X
X  (let
X    ( (import-list NIL) )
X
X    `(shadowing-import
X      ',(dolist (p *special-functions-list* import-list)
X         (push (cdr p) import-list)
X       )
X
X      )
X    )
X
X) ;end import-specialized-functions
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X
X
END_OF_FILE
if test 5643 -ne `wc -c <'co-sfun.l'`; then
    echo shar: \"'co-sfun.l'\" unpacked with wrong size!
fi
# end of 'co-sfun.l'
fi
if test -f 'co-test.l' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'co-test.l'\"
else
echo shar: Extracting \"'co-test.l'\" \(6054 characters\)
sed "s/^X//" >'co-test.l' <<'END_OF_FILE'
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; File:         co-test.l
X; RCS:          $Revision: 1.1 $
X; SCCS:         %A% %G% %U%
X; Description:  Portable Test Macro for Testing COOL
X; Author:       James Kempf, HP/DCC
X; Created:      24-Feb-87
X; Modified:     25-Feb-87 08:45:43 (James Kempf)
X; Language:     Lisp
X; Package:      PCL
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; Copyright (c) 1987 Hewlett-Packard Corporation. All rights reserved.
X;
X; Use and copying of this software and preparation of derivative works based
X; upon this software are permitted.  Any distribution of this software or
X; derivative works must comply with all applicable United States export
X; control laws.
X;
X; This software is made available AS IS, and Hewlett-Packard Corporation makes
X; no warranty about the software, its performance or its conformity to any
X; specification.
X;
X; Suggestions, comments and requests for improvement may be mailed to
X; [e-mail]
X
X;;;-*- Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted.  Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;;   CommonLoops Coordinator
X;;;   Xerox Artifical Intelligence Systems
X;;;   2400 Hanover St.
X;;;   Palo Alto, CA 94303
X;;; (or send Arpanet mail to [e-mail])
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X;;;
X;;; Testing code. Note: This file is derived from the PCL file test.l and
X;;; removes some of the PCL specific stuff from the test macro.
X
X(in-package 'pcl)
X(use-package 'lisp)
X
X(require "pcl")
X
X(export
X  '(
X    do-test
X  )
X)
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X;        Catching Errors
X;
X; Since CLtL defines no portable way of catching errors, most system
X; implementors have done their own. Certainly it would be possible
X; to code a portable error catcher, but the complexity involved
X; (catching errors at macroexpand time as well, etc.) is considerable.
X; As a stopgap, the *WITHOUT-ERRORS* special is provided for people
X; bringing up COOL on a new system to add their system's special error
X; catching code. It is taken from the original PCL test file.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;Other info needed for exception handling
X
X#+HP (require "exception")
X
X(defvar *without-errors*
X    (or #+Symbolics #'(lambda (form)
X                `(multiple-value-bind (.values. .errorp.)
X                 (si::errset ,form nil)
X                   (declare (ignore .values.))
X                   .errorp.))
X        #+Xerox     #'(lambda (form)
X                `(xcl:condition-case (progn ,form nil)
X                   (error () t)))
X
X            #+HP    #'(lambda (form)
X                `(extn:when-error
X                   (progn ,form NIL)
X                   T
X                )
X            )
X        nil
X        )
X
X) ;defvar
X
X;;without-errors-This macro generates code for error testing
X
X(defmacro without-errors (&body body)
X
X    (if *without-errors*
X      (funcall *without-errors* `(progn ,@body))
X      (error "Calling WITHOUT-ERRORS when *without-errors* is nil.")
X    )
X
X
X) ;without-errors
X
X;;with-return-value-Set up each form in BODY to match return value
X
X(defmacro with-return-value (form return-value)
X
X  ;;Note the use of full qualification on EQUALP
X  ;;  to avoid problems with redefinition from CO
X
X  `(lisp::equalp ',return-value ,form)
X
X) ;with-return-value
X
X;;do-test-Execute BODY according to the options list
X
X(defmacro do-test (name&options &body body)
X  (let
X    (
X      (name (if (listp name&options) (car name&options) name&options))
X      (options (if (listp name&options) (cdr name&options) ()))
X      (code NIL)
X    )
X
X    ;;Bind the options from keywords
X
X    (keyword-bind
X      (
X        (should-error nil)
X        (return-value nil)
X      )
X
X      options
X
X      ;;Check if errors should be caught and can be
X
X      (cond
X
X        ;;Errors can't be caught in this Lisp, so don't do it
X
X        (
X          (and should-error (null *without-errors*))
X      `(format t
X        "~&Skipping testing ~A,~%~
X         because can't ignore errors in this Common Lisp."
X         ',name
X          )
X        )
X
X        ;;Generate code for test. If the return value was supplied
X        ;;  as an option, check if the return values are the same.
X        ;;  Note the use of LISP::EQUALP. This is because CommonObjects
X        ;;  redefines EQUALP.
X
X        (t
X      `(progn
X        (format t "~&Testing ")
X        (format t ,name)
X        (format t "... ")
X            ,@(dolist (form  body (reverse code))
X                (push
X                  `(if
X             ,(cond
X            (
X              should-error
X              `(without-errors ,form)
X                        )
X                        (
X                          return-value
X                          `(with-return-value ,@form)
X                        )
X                        (
X                         T
X                         `(progn ,form)
X                        )
X                     )
X                     (format T "~&OK: ~S~%" ',form)
X             (format T "~&FAILED: ~S~%" ',form)
X                  )
X                  code
X
X               ) ;push
X            ) ;dolist
X
X          ) ;progn
X        )
X      ) ;cond
X
X    ) ;keyword-bind
X
X  ) ;let
X
X) ;do-test
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(provide "co-test")
X
END_OF_FILE
if test 6054 -ne `wc -c <'co-test.l'`; then
    echo shar: \"'co-test.l'\" unpacked with wrong size!
fi
# end of 'co-test.l'
fi
if test -f 'dfun-templ.l' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'dfun-templ.l'\"
else
echo shar: Extracting \"'dfun-templ.l'\" \(7420 characters\)
sed "s/^X//" >'dfun-templ.l' <<'END_OF_FILE'
X;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted.  Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;;   CommonLoops Coordinator
X;;;   Xerox Artifical Intelligence Systems
X;;;   2400 Hanover St.
X;;;   Palo Alto, CA 94303
X;;; (or send Arpanet mail to [e-mail])
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X;;;
X
X(in-package 'pcl)
X
X
X;;;
X;;; A caching discriminating function looks like:
X;;;   (lambda (arg-1 arg-2 arg-3 &rest rest-args)
X;;;     (prog* ((class-1 (class-of arg-1))
X;;;             (class-2 (class-of arg-2))
X;;;             method-function)
X;;;        (and (cached-method method-function CACHE MASK class-1 class-2)
X;;;             (go hit))
X;;;      miss
X;;;        (setq method-function
X;;;              (cache-method DISCRIMINATOR
X;;;                            (lookup-method-function DISCRIMINATOR
X;;;                                                    class-1
X;;;                                                    class-2)))
X;;;      hit
X;;;        (if method-function
X;;;            (return (apply method-function arg-1 arg-2 arg-3 rest-args))
X;;;            (return (no-matching-method DISCRIMINATOR)))))
X;;;
X;;; The upper-cased variables are the ones which are lexically bound.
X
X;;; There is a great deal of room to play here.  This open codes the
X;;; test to see if the instance is iwmc-class-p.  Only if it isn't is
X;;; there a function call to class-of.  This is done because we only have
X;;; a default implementation of make-discriminating-function, we don't
X;;; have one which is specific to discriminator-class DISCRIMINATOR and
X;;; meta-class CLASS.
X;;;
X;;; Of course a real implementation of CommonLoops wouldn't even do a
X;;; real function call to get to the discriminating function.
X
X(eval-when (compile load eval)
X
X(defun default-make-class-of-form-fn (arg)
X  `(if (iwmc-class-p ,arg)
X       (class-of--class ,arg)
X       (class-of ,arg)))
X
X(defvar *make-class-of-form-fn* #'default-make-class-of-form-fn)
X
X(define-function-template caching-discriminating-function
X                          (required restp
X                    specialized-positions
X                    lookup-function)
X                          '(.DISCRIMINATOR. .CACHE. .MASK.)
X  (let* ((args (iterate ((i from 0 below required))
X                 (collect (make-symbol (format nil "Disc-Fn-Arg ~D" i)))))
X         (class-bindings
X           (iterate ((i from 0 below required)
X                     (ignore in specialized-positions))
X             (if (member i specialized-positions)
X                 (collect
X           (list (make-symbol (format nil "Class of ARG ~D" i))
X             (funcall *make-class-of-form-fn* (nth i args))))
X                 (collect nil))))
X         (classes (remove nil (mapcar #'car class-bindings)))
X         (method-function-var (make-symbol "Method Function"))
X         (rest-arg-var (and restp (make-symbol "Disc-Fn-&Rest-Arg"))))
X    `(function
X       (lambda (,@args ,@(and rest-arg-var (list '&rest rest-arg-var)))
X         (prog (,@(remove nil class-bindings) ,method-function-var)
X       (and (cached-method ,method-function-var .CACHE. .MASK. ,@classes)
X        (go hit))
X      ;miss
X       (setq ,method-function-var
X         (cache-method .CACHE.
X                   .MASK.
X                   (,lookup-function .DISCRIMINATOR.
X                         ,@(mapcar #'car
X                               class-bindings))
X                   ,@classes))
X       hit
X       (if ,method-function-var
X           (return ,(if restp
X                `(apply ,method-function-var
X                    ,@args
X                    ,rest-arg-var)
X                `(funcall ,method-function-var ,@args)))
X           (no-matching-method .DISCRIMINATOR.)))))))
X)
X
X(eval-when (compile)
X(defmacro pre-make-caching-discriminating-functions (specs)
X  `(progn . ,(iterate ((spec in specs))
X           (collect `(pre-make-templated-function-constructor
X               caching-discriminating-function
X               ,@spec))))))
X
X(eval-when (load)
X  (pre-make-caching-discriminating-functions
X    ((2 NIL (0 1) LOOKUP-MULTI-METHOD)
X     (4 NIL (0) LOOKUP-CLASSICAL-METHOD)
X     (5 NIL (0) LOOKUP-CLASSICAL-METHOD)
X     (1 T (0) LOOKUP-CLASSICAL-METHOD)
X     (3 NIL (0 1) LOOKUP-MULTI-METHOD)
X     (4 T (0) LOOKUP-CLASSICAL-METHOD)
X     (3 T (0) LOOKUP-CLASSICAL-METHOD)
X     (3 NIL (0) LOOKUP-CLASSICAL-METHOD)
X     (1 NIL (0) LOOKUP-CLASSICAL-METHOD)
X     (2 NIL (0) LOOKUP-CLASSICAL-METHOD))))
X
X  ;;
X;;;;;;
X  ;;
X
X(eval-when (compile load eval)
X
X(define-function-template checking-discriminating-function
X    (required restp defaultp checks)
X    `(discriminator method-function default-function
X            ,@(make-checking-discriminating-function-1 checks))
X  (let* ((arglist (make-discriminating-function-arglist required restp)))
X    `(function
X       (lambda ,arglist
X     (declare (optimize (speed 3) (safety 0)))
X     discriminator default-function ;ignorable
X         (if (and ,@(iterate ((check in
X                     (make-checking-discriminating-function-1
X                       checks))
X                              (arg in arglist))
X                      (when (neq check 'ignore)
X            (collect
X              `(memq ,check
X                 (let ((.class. (class-of ,arg)))
X                   (get-slot--class .class.
X                            'class-precedence-list)))))))
X             ,(if restp
X                  `(apply method-function ,@(remove '&rest arglist))
X                  `(funcall method-function ,@arglist))
X             ,(if defaultp
X                  (if restp
X                      `(apply default-function ,@(remove '&rest arglist))
X                      `(funcall default-function ,@arglist))
X                  `(no-matching-method discriminator)))))))
X
X(defun make-checking-discriminating-function-1 (check-positions)
X  (iterate ((pos in check-positions))
X    (collect (if (null pos) 'ignore (intern (format nil "Check ~D" pos))))))
X
X)
X
X(eval-when (compile)
X(defmacro pre-make-checking-discriminating-functions (specs)
X  `(progn . ,(iterate ((spec in specs))
X           (collect `(pre-make-templated-function-constructor
X               checking-discriminating-function
X               ,@spec))))))
X
X(eval-when (load)
X  (pre-make-checking-discriminating-functions ((3 NIL NIL (0 1))
X                           (7 NIL NIL (0 1))
X                           (5 NIL NIL (0 1))
X                           (3 NIL NIL (0 NIL 2))
X                           (6 NIL NIL (0))
X                           (5 NIL NIL (0))
X                           (4 T NIL (0))
X                           (3 T NIL (0))
X                           (1 T NIL (0))
X                           (4 NIL NIL (0))
X                           (3 NIL NIL (0))
X                           (3 NIL T (0 1))
X                           (2 NIL T (0))
X                           (5 NIL T (0 1))
X                           (1 T T (0))
X                           (1 NIL T (0))
X                           (2 NIL T (0 1))
X                           (3 NIL T (0))
X                           (2 T T (0))
X                           (6 NIL T (0 1))
X                           (3 NIL T (0 NIL 2))
X                           (4 NIL T (0 1))
X                           (4 NIL T (0))
X                           (5 NIL T (0))
X                           (1 NIL NIL (0))
X                           (2 NIL NIL (0)))))
X
END_OF_FILE
if test 7420 -ne `wc -c <'dfun-templ.l'`; then
    echo shar: \"'dfun-templ.l'\" unpacked with wrong size!
fi
# end of 'dfun-templ.l'
fi
if test -f 'pcl-patches.l' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'pcl-patches.l'\"
else
echo shar: Extracting \"'pcl-patches.l'\" \(6462 characters\)
sed "s/^X//" >'pcl-patches.l' <<'END_OF_FILE'
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; File:         pcl-patches.l
X; RCS:          $Revision: 1.1 $
X; SCCS:         %A% %G% %U%
X; Description:  Patches to Released PCL so CommonObjects works
X; Author:       James Kempf, HP/DCC
X; Created:      11-Nov-86
X; Modified:     5-Mar-87 08:04:02 (James Kempf)
X; Language:     Lisp
X; Package:      PCL
X; Status:       Distribution
X;
X; (c) Copyright 1987, HP Labs, all rights reserved.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; Copyright (c) 1987 Hewlett-Packard Corporation. All rights reserved.
X;
X; Use and copying of this software and preparation of derivative works based
X; upon this software are permitted.  Any distribution of this software or
X; derivative works must comply with all applicable United States export
X; control laws.
X;
X; This software is made available AS IS, and Hewlett-Packard Corporation makes
X; no warranty about the software, its performance or its conformity to any
X; specification.
X;
X; Suggestions, comments and requests for improvement may be mailed to
X; [e-mail]
X
X;;Need the PCL module
X
X(require "pcl")
X
X(in-package 'pcl)
X(use-package 'lisp)
X
X;;These symbols are needed by CommonObjects
X
X(export
X  '(
X    print-instance
X    make-specializable
X    rename-class
X    call-next-method
X    expand-with-make-entries
X    method-type-specifiers
X    method-arglist
X  )
X)
X
X;;Note-Every implementation of CL will need to add the
X;;  check for nonatomic type specifiers.
X
X#+HP(setq *class-of*
X    '(lambda (x)
X       (cond ((%instancep x)
X          (%instance-class-of x))
X         ;; Ports of PCL should define the rest of class-of
X         ;; more meaningfully.  Because of the underspecification
X                 ;; of type-of this is the best that I can do.
X         ((null x)
X                  (class-named 'null))
X                 ((stringp x)
X                  (class-named 'string))
X         ((characterp x)
X          (class-named 'character))
X         (t
X          (or (class-named (atom-type-of (type-of x)) t)
X              (error "Can't determine class of ~S." x)
X          ))
X            )
X        )
X)
X
X#+ExCL(eval-when (load)
X  (setq *class-of*
X    '(lambda (x)
X       (or (and (%instancep x)
X            (%instance-class-of x))
X          ;(%funcallable-instance-p x)
X           (and (stringp x) (class-named 'string))
X           (class-named (type-of x) t)
X           (error "Can't determine class of ~S." x)))
X  )
X
X)
X
X;;Now arrange things so CLASS-OF gets recompiled when this file gets
X;;  loaded
X
X#-KCL(eval-when (load eval)
X
X  (recompile-class-of)
X
X)
X
X;;atom-type-of-Return principle type. This is the first
X;;  item on the type specifier list, or specifier itself,
X;;  if the specifier is atomic.
X
X(defun atom-type-of (x)
X
X  (if (listp x)
X    (car x)
X    x
X  )
X
X) ;end atom-type-of
X
X;;
X;;
X;;
X;;
X;; Default print-instance method
X;;
X;;
X;;
X
X(defmeth print-instance (instance stream depth)
X  (printing-random-thing (instance stream)
X    (format stream "instance ??")))
X
X;;;New for CO
X
X
X;;rename-class-Find the class object named old-name and rename to
X;;  new-name
X
X(defmeth rename-class ((old-name symbol) (new-name symbol))
X
X  (rename-class (class-named old-name) new-name)
X
X) ;end rename-class
X
X
X;;rename-class-Change the name of the essential class's name to name
X
X(defmeth rename-class ((class essential-class) (name symbol))
X
X  (let
X    (
X      (old-name (class-name class))
X    )
X
X
X    (setf (class-name class) name)
X
X    ;;Needed to be sure the naming hash table is OK
X
X    (setf (class-named name) class)
X    (setf (class-named old-name) NIL)
X    name
X  )
X
X) ;end rename-class
X
X
X;;
X;;
X;;
X;; From class-prot.l
X;;
X;;
X;;
X
X;;JAK 2/15/86 Additional bug. OPTIMIZE-GET-SLOT and OPTIMIZE-SETF-OF
X;;  GET-SLOT didn't seem to be getting called. This version calls
X;;  them. NOTE-this has been added to CLASS-PROT.L so that the
X;;  optimization functions get called in the kernel as well.
X
X(defun expand-with-slots
X       (proto-discriminator proto-method first-arg env body)
X  (ignore proto-discriminator)
X  (let ((entries (expand-with-make-entries proto-method first-arg))
X    (gensyms ()))
X    (dolist (arg first-arg)
X      (push (list (if (listp arg) (car arg) arg)
X          (gensym))
X        gensyms))
X    `(let ,(mapcar #'reverse gensyms)
X       ,(walk-form (cons 'progn body)
X      :environment env
X      :walk-function
X      #'(lambda (form context &aux temp)
X          (cond ((and (symbolp form)
X              (eq context ':eval)
X              (null (variable-lexical-p form))
X              (null (variable-special-p form))
X              (setq temp (assq form entries)))
X             (if (car (cddddr temp))    ;use slot-value?
X                         (optimize-get-slot
X                          ;;;;  proto-method     ;;the method object ;rds 3/8
X                           (third temp)        ;;the class object
X               `(get-slot ,(cadr (assq (cadr temp) gensyms))
X                    ',(slotd-name (cadddr temp)))
X                         )
X             `(,(slotd-accessor (cadddr temp))
X               ,(cadr (assq (cadr temp) gensyms)))))
X            ((and (listp form)
X              (or (eq (car form) 'setq)
X                  (eq (car form) 'setf)))
X             (cond ((cdddr form)
X                (cons 'progn
X                  (iterate ((pair on (cdr form) by cddr))
X                    (collect (list (car form)
X                           (car pair)
X                           (cadr pair))))))
X               ((setq temp (assq (cadr form) entries))
X
X;;JAK 2/14/87 Bug found. The following IF was not included, causing
X;;  the second form to always be returned. This caused forms like
X;;;  (SETF (NIL #:G1234) 5) to be generated, which aren't SETF expandable
X
X                 (if (not (slotd-accessor (cadddr temp)))
X                   (optimize-setf-of-get-slot
X                    ;;; proto-method  ; rds 3/8
X                                 (third temp)
X                     `(setf-of-get-slot
X                       ,(cadr (assq (cadr temp) gensyms))
X                       ',(slotd-name (cadddr temp))
X                       ,(caddr form))
X                )
X
X                   `(setf (,(slotd-accessor (cadddr temp))
X                    ,(cadr (assq (cadr temp) gensyms)))
X                   ,(caddr form))))
X               (t form)))
X            (t form)))))))
X
X;;Default methods for optimize-get-slot and optimize-setf-of-get-slot
X
X; rds 3/9 changed arglist to conform to new PCL
X; (defmeth optimize-get-slot (method class form)
X;  form
X;)
X(defmeth optimize-get-slot (class form)
X form
X )
X
X; rds 3/9 changed arglist to conform to new PCL
X;(defmeth optimize-setf-of-get-slot (method class form)
X;  form
X;)
X(defmeth optimize-setf-of-get-slot (class form)
X form
X )
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(provide "pcl-patches")
X
END_OF_FILE
if test 6462 -ne `wc -c <'pcl-patches.l'`; then
    echo shar: \"'pcl-patches.l'\" unpacked with wrong size!
fi
# end of 'pcl-patches.l'
fi
if test -f 'xerox-low.l' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'xerox-low.l'\"
else
echo shar: Extracting \"'xerox-low.l'\" \(5605 characters\)
sed "s/^X//" >'xerox-low.l' <<'END_OF_FILE'
X;;; -*- Mode:LISP; Package:(PCL Lisp 1000); Base:10.; Syntax:Common-lisp -*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted.  Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;;   CommonLoops Coordinator
X;;;   Xerox Artifical Intelligence Systems
X;;;   2400 Hanover St.
X;;;   Palo Alto, CA 94303
X;;; (or send Arpanet mail to [e-mail])
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X;;;
X;;; This is the 1100 (Xerox version) of the file portable-low.
X;;;
X
X(in-package 'pcl)
X
X(defmacro load-time-eval (form)
X  `(il:LOADTIMECONSTANT ,form))
X
X  ;;
X;;;;;; Memory block primitives.
X  ;;
X
X; what I have done is to replace all calls to il:\\RPLPTR with a call to
X; RPLPTR (in the PCL) package.  RPLPTR is a version which does some error
X; checking and then calls il:\\RPLPTR.  As follows:
X
X;(defun rplptr (block index value)
X;  (if (< index (* (il:\\#blockdatacells block) 2))
X;      (il:\\rplptr block index value)
X;      (error "bad args to rplptr")))
X
X(defmacro make-memory-block (size &optional area)
X  `(il:\\allocblock ,size T))
X
X(defmacro memory-block-ref (block offset)
X  `(il:\\GETBASEPTR ,block (* ,offset 2)))
X
X(defsetf memory-block-ref (memory-block offset) (new-value)
X  `(il:\\rplptr ,memory-block (* ,offset 2) ,new-value))
X
X(defmacro memory-block-size (block)
X  ;; this returns the amount of memory allocated for the block --
X  ;; it may be larger than size passed at creation
X  `(il:\\#BLOCKDATACELLS ,block))
X
X(defmacro CLEAR-memory-block (block start)
X  (once-only (block)
X    `(let ((end (* (il:\\#blockdatacells ,block) 2)))
X       (do ((index (* ,start 2) (+ index 2)))
X       ((= index end))
X     (il:\\rplptr ,block index nil)))))
X
X  ;;
X;;;;;; Static slot storage primitives
X  ;;
X
X;;;
X;;; Once everything sees to work, uncomment this back into play and remove
X;;; the * 2 in the other places.
X;;;
X;(defmacro %convert-slotd-position-to-slot-index (slotd-position)
X; `(* 2 ,slotd-position))
X
X(defmacro %allocate-static-slot-storage--class (no-of-slots)
X  `(il:\\ALLOCBLOCK ,no-of-slots t))
X
X(defmacro %static-slot-storage-get-slot--class (static-slot-storage
X                        slot-index)
X  `(il:\\GETBASEPTR ,static-slot-storage (* ,slot-index 2)))
X
X(defsetf %static-slot-storage-get-slot--class (static-slot-storage
X                           slot-index)
X                          (new-value)
X  `(il:\\rplptr ,static-slot-storage (* ,slot-index 2) ,new-value))
X
X
X  ;;
X;;;;;; Instance With Meta-Class Class (IWMC-CLASS)
X  ;;
X;;; In Xerox Lisp, the type of an object is inextricably linked to its size.
X;;; This means that we can't build IWMC-CLASS on top of %instance and still
X;;; get rid of the indirection to instance-storage the way we would like to.
X;;; So, we build iwmc-class on its own base using defstruct.
X;;;
X;;; NOTE: %instance-meta-class will not return the right value for an
X;;;       instance
X
X(eval-when (compile load eval)
X  ;; see if we can save our implementation of macros from itself
X  (dolist (x '(iwmc-class-class-wrapper
X           iwmc-class-static-slots
X           iwmc-class-dynamic-slots))
X    (fmakunbound x)
X    (remprop x 'il:macro-fn)))
X
X(defstruct (iwmc-class (:predicate iwmc-class-p)
X               (:conc-name iwmc-class-)
X               (:constructor %%allocate-instance--class ())
X               (:print-function print-instance))
X  (class-wrapper nil)
X  (static-slots nil)
X  (dynamic-slots ()))
X
X(defmacro %allocate-instance--class (no-of-slots &optional class-class)
X  `(let ((iwmc-class (%%allocate-instance--class)))
X     (%allocate-instance--class-1 ,no-of-slots iwmc-class)
X     iwmc-class))
X
X
X(defmacro %allocate-class-class (no-of-slots)    ;This is used to allocate the
X  `(let ((i (%%allocate-instance--class)))    ;class class.  It bootstraps
X    ;(setf (%instance-meta-class i) i)        ;the call to class-named in
X     (setf (class-named 'class) i)        ;%allocate-instance--class.
X     (%allocate-instance--class-1 ,no-of-slots i)
X     i))
X
X(eval-when (compile load eval)
X  (setq *class-of*
X    '(lambda (x)
X       (or (and (iwmc-class-p x)
X            (class-of--class x))
X           (and (%instancep x)
X            (%instance-class-of x))
X          ;(%funcallable-instance-p x)
X           (class-named (type-of x) t)
X           (error "Can't determine class of ~S" x))))
X
X  (setq *meta-classes* (delete (assq 'class *meta-classes*) *meta-classes*)))
X
X
X
X  ;;
X;;;;;; FUNCTION-ARGLIST
X  ;;
X
X(defun function-arglist (x) (il:arglist x))
X
X  ;;
X;;;;;; Generating CACHE numbers
X  ;;
X
X(defmacro symbol-cache-no (symbol mask)
X  `(logand (il:llsh (logand #o17777 (il:\\loloc ,symbol)) 2) ,mask))
X
X(defmacro object-cache-no (object mask)
X  `(logand (il:\\loloc ,object) ,mask))
X
X
X  ;;
X;;;;;; printing-random-thing-internal
X  ;;
X
X(defun printing-random-thing-internal (thing stream)
X  (princ (il:\\hiloc thing) stream)
X  (princ "," stream)
X  (princ (il:\\loloc thing) stream))
X
X(defun record-definition (name type &optional parent-name parent-type)
X  (declare (ignore type parent-name))
X  ())
X
END_OF_FILE
if test 5605 -ne `wc -c <'xerox-low.l'`; then
    echo shar: \"'xerox-low.l'\" unpacked with wrong size!
fi
# end of 'xerox-low.l'
fi
echo shar: End of archive 2 \(of 13\).
cp /dev/null ark2isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 13 archives.
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0
--

Rich $alz            "Anger is an energy"
Cronus Project, BBN Labs    [e-mail]
Moderator, comp.sources.unix    [e-mail]